PC-Blue - MS DOS Public Domain Library/PC-Blue MS-DOS Public Domain Library - NYACC.iso/vol247/date20.inc

Text File | 1986-12-01 | 12.8 KB | 392 lines

{ DATE20.INC -- Routines to write, read and compare dates, etc.
  Version 2.0 includes type declarations in this module and allows
  entry of a null date (00/00/0000).   WPM -- 1/19/86 .
  Cosmetic improvement -- 4/16/86 }

type
    date = record
        yr : integer ; { 0 .. 9999 }
        mo : integer ; { 1 .. 12 }
        dy : integer ; { 1 .. 31 }
      end ;

    datestring = string[10] ;  { 'MM/DD/YYYY' }

    juldate = record
        yr  : integer ; { 0 .. 9999 }
        day : integer ; { 1 .. 366 }
      end ;

    juldatestring = string[8] ; { 'YYYY/DDD' }

    montharray = array [1 .. 13] of integer ;

const
    monthtotal : montharray = (0,31,59,90,120,151,181,212,243,273,304,334,365) ;
                 { used to convert julian date to gregorian and back }

    null_date  : date       = (yr:0 ; mo:0 ; dy:0) ;
    null_date_str : datestring = 'MM/DD/YYYY' ;


{ ------------------------------------------------------------ }

function mk_dt_st (dt : date) : datestring ;
  { Makes a string out of a date -- used for printing dates }
    var
        yr_st : string[4] ;
        mo_st : string[2] ;
        dy_st : string[2] ;
        dt_st : datestring ;
    begin
        with dt do
          begin
            if (yr=0) and (mo=0) and (dy=0) then
                dt_st := 'MM/DD/YYYY'
            else
              begin
                str (yr:4,yr_st) ;
                str (mo:2,mo_st) ;
                str (dy:2,dy_st) ;
                dt_st := concat (mo_st,'/',dy_st,'/',yr_st)
              end  { else }
          end ;  { with dt do }
        mk_dt_st := dt_st
    end ;  { --- proc mk_dt_st --- }

{ ------------------------------------------------------------ }

procedure write_date (dt: date ; col, row: integer) ;
  { Writes date at column and row specified }
    var
        ds : datestring ;
    begin
        ds := mk_dt_st (dt) ;
        write_str (ds,col,row)
    end ; { --- proc write_date --- }

{ ------------------------------------------------------------ }

function mk_jul_dt_st (jdt : juldate) : juldatestring ;
{ makes a string out of a julian date }
  var
      yr_st  : string[4] ;
      day_st : string[3] ;
      jdt_st : juldatestring ;
  begin
      with jdt do
        if (yr=0) and (day = 0) then
            jdt_st := 'YYYY/DDD'
        else
          begin
            str(yr:4,yr_st) ;
            str(day:3,day_st) ;
            jdt_st := concat (yr_st,'/',day_st)
          end ;
      mk_jul_dt_st := jdt_st
  end ;  { function mk_jul_dt_st }

{ ------------------------------------------------------------ }

function leapyear (yr : integer) : boolean ;
{ Whether the year is a leap year or not.
  The year is year and century, e.g. year '1984' is 1984, not 84 }
  begin
    leapyear := ((yr mod 4 = 0) and (not(yr mod 100 = 0)))
             or ( yr mod 400 = 0 )
  end ;

{ ------------------------------------------------------------ }

function valid_date (dt:date) : boolean ;
  { Test whether date is valid }
    var
        bad_fld : integer ;
    begin
        bad_fld := 0 ;
        with dt do
            begin
                if (mo = 0) and (dy = 0) and (yr = 0) then
                    bad_fld := 0
                else if not (mo in [1 .. 12]) then
                        bad_fld := 1
                else if (dy > 31)
                or (dy < 1)
                or ((mo in [4,6,9,11]) and (dy > 30)) then
                        bad_fld := 2
                else if mo = 2 then
                  begin
                    if (leapyear(yr) and (dy > 29))
                    or ((not leapyear(yr)) and (dy > 28)) then
                        bad_fld := 2
                  end
                else if yr = 0 then
                        bad_fld := 3
            end ; { with dt do }
        valid_date := (bad_fld = 0)
    end ; { function valid_date }

{ ------------------------------------------------------------ }

procedure read_date (var dt: date ; col, row: integer) ;

  { Read date at column and row specified.  If the user enters only
    two digits for the year, the procedure plugs the century as 1900 or
    2000, but the user can enter all four digits to override the plug. }

    var
        savefld, bad_fld : integer ;

    procedure edit_date ;                  { Edit for valid date }
        begin
            bad_fld := 0 ;
            with dt do
                begin
                    if (mo = 0) and (dy = 0) and (yr = 0) then
                        bad_fld := 0
                    else if not (mo in [1 .. 12]) then
                        begin
                            mo  := 0 ;
                            bad_fld := 1
                        end
                    else if (dy > 31)
                    or (dy < 1)
                    or ((mo in [4,6,9,11]) and (dy > 30)) then
                        begin
                            dy  := 0 ;
                            bad_fld := 2
                        end
                    else if mo = 2 then
                      begin
                        if (leapyear(yr) and (dy > 29))
                        or ((not leapyear(yr)) and (dy > 28)) then
                            begin
                                dy  := 0 ;
                                bad_fld := 2
                            end
                      end
                    else if yr = 0 then
                            bad_fld := 3
                end   { with dt do }
        end ; { --- of edit_date --- }

    begin { read_date }
        savefld := fld ;                    { Save FLD for rest of screen }
        fld := 1 ;                          { Set up FLD for use locally }
        write_date (dt, col, row) ;
        with dt do
            repeat
                repeat
                    case fld of
                        1 : read_int (mo, 2, col, row) ;
                        2 : read_int (dy, 2, col+3, row) ;
                        3 : begin
                              read_int (yr, 4, col+6, row) ;
                              if  (yr < 0) then
                                begin
                                  yr := 0 ;
                                  if (fld > 3) and (fld < maxint) then
                                      fld := 3
                                end
                              else if not((yr = 0) and (mo = 0) and (dy = 0)) then
                                begin
                                  if yr < 80 then         { Plug century }
                                      yr := 2000 + yr
                                  else if yr < 100 then
                                      yr := 1900 + yr
                                end ;
                              write_int (yr, 4, col+6, row)
                            end ; { 3 }
                    end ; { CASE }
                until (fld < 1) or (fld > 3) ;
                if (fld > 3) and (fld < maxint) then      { edit only }
                  begin                                   { going forward }
                    edit_date ;
                    if not (bad_fld = 0) then   { Date is bad }
                        begin
                            beep ;
                            fld := bad_fld
                        end
                  end
            until (fld < 1) or (fld > 3) ;
        write_date (dt,col,row) ;
        if fld = 0 then                     { Restore FLD for rest of screen }
                fld := savefld - 1
        else if fld = 4 then
                fld := savefld + 1

    end ; {--- of read_date ---}

{ ------------------------------------------------------------ }

function greater_date (dt1, dt2 : date) : integer ;
  { Compares two dates, returns 0 if both equal, 1 if first is
    greater, 2 if second is greater.  Converts both to strings,
    then compares the strings. }

    var
        stdt1, stdt2 : string[8] ;
        styr1, styr2 : string[4] ;
        stmo1, stmo2 : string[2] ;
        stdy1, stdy2 : string[2] ;

    begin
        with dt1 do
            begin
                str(yr:4,styr1) ;
                str(mo:2,stmo1) ;
                str(dy:2,stdy1) ;
                stdt1 := concat (styr1,stmo1,stdy1)
            end ;
        with dt2 do
            begin
                str(yr:4,styr2) ;
                str(mo:2,stmo2) ;
                str(dy:2,stdy2) ;
                stdt2 := concat (styr2,stmo2,stdy2)
            end ;
        if stdt1 > stdt2 then
                greater_date := 1
        else if stdt2 > stdt1 then
                greater_date := 2
        else { both equal }
                greater_date := 0
    end ; { --- of greater_date --- }

{ ------------------------------------------------------------ }

procedure greg_to_jul (dt : date ; var jdt : juldate) ;
{ converts a gregorian date to a julian date }
  begin
    jdt.yr := dt.yr ;
    if (dt.yr = 0) and (dt.mo = 0) and (dt.dy = 0) then
        jdt.day := 0
    else
      begin
        if (leapyear(dt.yr)) and (dt.mo > 2) then
            jdt.day := 1
        else
            jdt.day := 0 ;
        jdt.day := jdt.day + monthtotal[dt.mo] + dt.dy
      end
  end ;  { --- procedure greg_to_jul --- }

{ ------------------------------------------------------------ }

procedure jul_to_greg (jdt : juldate ; var dt : date) ;
{ converts a julian date to a gregorian date }
  var
      i, workday : integer ;
  begin
    dt.yr := jdt.yr ;
    if (jdt.yr = 0) and (jdt.day = 0) then
      begin
        dt.mo := 0 ; dt.dy := 0
      end
    else
      begin
        workday := jdt.day ;
        if (leapyear(jdt.yr)) and (workday > 59) then
            workday := workday - 1 ;   { make it look like a non-leap year }
        i := 1 ;
        repeat
            i := i + 1
        until not (workday > monthtotal[i]) ;
        i := i - 1 ;
        dt.mo := i ;
        dt.dy := workday - monthtotal[i] ;
        if leapyear(jdt.yr) and (jdt.day = 60) then
            dt.dy := dt.dy + 1
      end
  end ;  { --- procedure jul_to_greg --- }

{ ------------------------------------------------------------ }

procedure next_day (var dt : date) ;
  { Adds one day to the date }
    var
        jdt  : juldate ;
        leap : boolean ;
    begin
        greg_to_jul (dt,jdt) ;
        jdt.day := jdt.day + 1 ;
        leap := leapyear (dt.yr) ;
        if (leap and (jdt.day = 367))
        or (not leap and (jdt.day = 366)) then
          begin
            jdt.yr := jdt.yr + 1 ;
            jdt.day := 1
          end ;
        jul_to_greg (jdt,dt)
    end ;  { --- procedure next_day --- }

{ ------------------------------------------------------------ }

procedure prev_day (var dt : date) ;
  { Subtracts one day from the date }
    var
        jdt : juldate ;
    begin
        greg_to_jul (dt,jdt) ;
        jdt.day := jdt.day - 1 ;
        if jdt.day < 1 then
          begin
            jdt.yr := jdt.yr - 1 ;
            if leapyear (jdt.yr) then
                jdt.day := 366
            else
                jdt.day := 365
          end ;
        jul_to_greg (jdt,dt)
    end ;  { --- procedure prev_day --- }

{ ------------------------------------------------------------ }

function date_diff (dt1, dt2 : date) : real ;
  { computes the number of days between two dates }
    var
        jdt1, jdt2 : juldate ;
        i, num_leap_yrs : integer ;
    begin
        greg_to_jul (dt1, jdt1) ;
        greg_to_jul (dt2, jdt2) ;

        num_leap_yrs := 0 ;         { adjust for leap years }
        if dt2.yr > dt1.yr then
          begin
            for i := dt1.yr to dt2.yr - 1 do
                if leapyear(i) then
                    num_leap_yrs := num_leap_yrs + 1
          end
        else if dt1.yr > dt2.yr then
          begin
            for i := dt2.yr to dt1.yr - 1 do
                if leapyear(i) then
                    num_leap_yrs := num_leap_yrs - 1
          end ;

        date_diff := jdt2.day - jdt1.day + ((jdt2.yr - jdt1.yr) * 365.0) + num_leap_yrs
    end ;

{ ------------------------------------------------------------ }

function month_diff (dt1, dt2 : date ) : integer ;
  { Computes number of months between two dates, rounded.
    30.4167 = 356/12, average number of days in a month. }
    begin
        month_diff := round((date_diff(dt1, dt2) + 1) / 30.4167)
    end ;

{ ------------------------------------------------------------ }

function equal_date (dt1, dt2 : date) : boolean ;
  { Tests whether two dates are equal }
    begin
        equal_date := (dt1.mo = dt2.mo) and (dt1.dy = dt2.dy)
                      and (dt1.yr = dt2.yr)
    end ;

{ ----- EOF DATE20.INC --------------------------------------- }
rs + 1
          end
        else if dt1.yr > d